home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / GIMP 2.6.8 / gimp-2.6.8-i686-setup.exe / {app} / share / gimp / 2.0 / scripts / script-fu.init < prev    next >
Text File  |  2009-12-15  |  19KB  |  585 lines
  1. ;    Initialization file for TinySCHEME 1.38
  2.  
  3. ; Per R5RS, up to four deep compositions should be defined
  4. (define (caar x) (car (car x)))
  5. (define (cadr x) (car (cdr x)))
  6. (define (cdar x) (cdr (car x)))
  7. (define (cddr x) (cdr (cdr x)))
  8. (define (caaar x) (car (car (car x))))
  9. (define (caadr x) (car (car (cdr x))))
  10. (define (cadar x) (car (cdr (car x))))
  11. (define (caddr x) (car (cdr (cdr x))))
  12. (define (cdaar x) (cdr (car (car x))))
  13. (define (cdadr x) (cdr (car (cdr x))))
  14. (define (cddar x) (cdr (cdr (car x))))
  15. (define (cdddr x) (cdr (cdr (cdr x))))
  16. (define (caaaar x) (car (car (car (car x)))))
  17. (define (caaadr x) (car (car (car (cdr x)))))
  18. (define (caadar x) (car (car (cdr (car x)))))
  19. (define (caaddr x) (car (car (cdr (cdr x)))))
  20. (define (cadaar x) (car (cdr (car (car x)))))
  21. (define (cadadr x) (car (cdr (car (cdr x)))))
  22. (define (caddar x) (car (cdr (cdr (car x)))))
  23. (define (cadddr x) (car (cdr (cdr (cdr x)))))
  24. (define (cdaaar x) (cdr (car (car (car x)))))
  25. (define (cdaadr x) (cdr (car (car (cdr x)))))
  26. (define (cdadar x) (cdr (car (cdr (car x)))))
  27. (define (cdaddr x) (cdr (car (cdr (cdr x)))))
  28. (define (cddaar x) (cdr (cdr (car (car x)))))
  29. (define (cddadr x) (cdr (cdr (car (cdr x)))))
  30. (define (cdddar x) (cdr (cdr (cdr (car x)))))
  31. (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
  32.  
  33. (macro (unless form)
  34.      `(if (not ,(cadr form)) (begin ,@(cddr form))))
  35.  
  36. (macro (when form)
  37.      `(if ,(cadr form) (begin ,@(cddr form))))
  38.  
  39. ; DEFINE-MACRO Contributed by Andy Gaynor
  40. (macro (define-macro dform)
  41.   (if (symbol? (cadr dform))
  42.     `(macro ,@(cdr dform))
  43.     (let ((form (gensym)))
  44.       `(macro (,(caadr dform) ,form)
  45.          (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
  46.  
  47. ; Utilities for math. Notice that inexact->exact is primitive,
  48. ; but exact->inexact is not.
  49. (define exact? integer?)
  50. (define (inexact? x) (and (real? x) (not (integer? x))))
  51. (define (even? n) (= (remainder n 2) 0))
  52. (define (odd? n) (not (= (remainder n 2) 0)))
  53. (define (zero? n) (= n 0))
  54. (define (positive? n) (> n 0))
  55. (define (negative? n) (< n 0))
  56. (define complex? number?)
  57. (define rational? real?)
  58. (define (abs n) (if (>= n 0) n (- n)))
  59. (define (exact->inexact n) (* n 1.0))
  60. (define (<> n1 n2) (not (= n1 n2)))
  61. (define (max . lst)
  62.      (foldr (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst)))
  63. (define (min . lst)
  64.      (foldr (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst)))
  65. (define (succ x) (+ x 1))
  66. (define (pred x) (- x 1))
  67. (define gcd
  68.   (lambda a
  69.     (if (null? a)
  70.       0
  71.       (let ((aa (abs (car a)))
  72.         (bb (abs (cadr a))))
  73.          (if (= bb 0)
  74.               aa
  75.               (gcd bb (remainder aa bb)))))))
  76. (define lcm
  77.   (lambda a
  78.     (if (null? a)
  79.       1
  80.       (let ((aa (abs (car a)))
  81.         (bb (abs (cadr a))))
  82.          (if (or (= aa 0) (= bb 0))
  83.              0
  84.              (abs (* (quotient aa (gcd aa bb)) bb)))))))
  85.  
  86. (define call/cc call-with-current-continuation)
  87.  
  88. (define (string . charlist)
  89.      (list->string charlist))
  90.  
  91. (define (list->string charlist)
  92.      (let* ((len (length charlist))
  93.             (newstr (make-string len))
  94.             (fill-string!
  95.                (lambda (str i len charlist)
  96.                     (if (= i len)
  97.                          str
  98.                          (begin (string-set! str i (car charlist))
  99.                          (fill-string! str (+ i 1) len (cdr charlist)))))))
  100.           (fill-string! newstr 0 len charlist)))
  101.  
  102. (define (string-fill! s e)
  103.      (let ((n (string-length s)))
  104.           (let loop ((i 0))
  105.                (if (= i n)
  106.                     s
  107.                     (begin (string-set! s i e) (loop (succ i)))))))
  108.  
  109. (define (string->list s)
  110.      (let loop ((n (pred (string-length s))) (l '()))
  111.           (if (= n -1)
  112.                l
  113.                (loop (pred n) (cons (string-ref s n) l)))))
  114.  
  115. (define (string-copy str)
  116.      (string-append str))
  117.  
  118. (define (string->anyatom str pred . radix)
  119.      (let* ((a (string->atom str)))
  120.        (if (pred a) a
  121.        (error "string->xxx: not a xxx" a))))
  122.  
  123. (define (string->number str . radix) (string->anyatom str number? radix))
  124.  
  125. (define (anyatom->string n pred)
  126.   (if (pred n)
  127.       (atom->string n)
  128.       (error "xxx->string: not a xxx" n)))
  129.  
  130.  
  131. (define (number->string n) (anyatom->string n number?))
  132.  
  133. (define (char-cmp? cmp a b)
  134.      (cmp (char->integer a) (char->integer b)))
  135. (define (char-ci-cmp? cmp a b)
  136.      (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
  137.  
  138. (define (char=? a b) (char-cmp? = a b))
  139. (define (char<? a b) (char-cmp? < a b))
  140. (define (char>? a b) (char-cmp? > a b))
  141. (define (char<=? a b) (char-cmp? <= a b))
  142. (define (char>=? a b) (char-cmp? >= a b))
  143.  
  144. (define (char-ci=? a b) (char-ci-cmp? = a b))
  145. (define (char-ci<? a b) (char-ci-cmp? < a b))
  146. (define (char-ci>? a b) (char-ci-cmp? > a b))
  147. (define (char-ci<=? a b) (char-ci-cmp? <= a b))
  148. (define (char-ci>=? a b) (char-ci-cmp? >= a b))
  149.  
  150. ; Note the trick of returning (cmp x y)
  151. (define (string-cmp? chcmp cmp a b)
  152.      (let ((na (string-length a)) (nb (string-length b)))
  153.           (let loop ((i 0))
  154.                (cond
  155.                     ((= i na)
  156.                          (if (= i nb) (cmp 0 0) (cmp 0 1)))
  157.                     ((= i nb)
  158.                          (cmp 1 0))
  159.                     ((chcmp = (string-ref a i) (string-ref b i))
  160.                          (loop (succ i)))
  161.                     (else
  162.                          (chcmp cmp (string-ref a i) (string-ref b i)))))))
  163.  
  164.  
  165. (define (string=? a b) (string-cmp? char-cmp? = a b))
  166. (define (string<? a b) (string-cmp? char-cmp? < a b))
  167. (define (string>? a b) (string-cmp? char-cmp? > a b))
  168. (define (string<=? a b) (string-cmp? char-cmp? <= a b))
  169. (define (string>=? a b) (string-cmp? char-cmp? >= a b))
  170.  
  171. (define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
  172. (define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
  173. (define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
  174. (define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
  175. (define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
  176.  
  177. (define (list . x) x)
  178.  
  179. (define (foldr f x lst)
  180.      (if (null? lst)
  181.           x
  182.           (foldr f (f x (car lst)) (cdr lst))))
  183.  
  184. (define (unzip1-with-cdr . lists)
  185.   (unzip1-with-cdr-iterative lists '() '()))
  186.  
  187. (define (unzip1-with-cdr-iterative lists cars cdrs)
  188.   (if (null? lists)
  189.       (cons cars cdrs)
  190.       (let ((car1 (caar lists))
  191.         (cdr1 (cdar lists)))
  192.     (unzip1-with-cdr-iterative
  193.      (cdr lists)
  194.      (append cars (list car1))
  195.      (append cdrs (list cdr1))))))
  196.  
  197. (define (map proc . lists)
  198.   (if (null? lists)
  199.       (apply proc)
  200.       (if (null? (car lists))
  201.       '()
  202.       (let* ((unz (apply unzip1-with-cdr lists))
  203.          (cars (car unz))
  204.          (cdrs (cdr unz)))
  205.         (cons (apply proc cars) (apply map (cons proc cdrs)))))))
  206.  
  207. (define (for-each proc . lists)
  208.   (if (null? lists)
  209.       (apply proc)
  210.       (if (null? (car lists))
  211.       #t
  212.       (let* ((unz (apply unzip1-with-cdr lists))
  213.          (cars (car unz))
  214.          (cdrs (cdr unz)))
  215.         (apply proc cars) (apply map (cons proc cdrs))))))
  216.  
  217. (define (list-tail x k)
  218.     (if (zero? k)
  219.         x
  220.         (list-tail (cdr x) (- k 1))))
  221.  
  222. (define (list-ref x k)
  223.     (car (list-tail x k)))
  224.  
  225. (define (last-pair x)
  226.     (if (pair? (cdr x))
  227.         (last-pair (cdr x))
  228.         x))
  229.  
  230. (define (head stream) (car stream))
  231.  
  232. (define (tail stream) (force (cdr stream)))
  233.  
  234. (define (vector-equal? x y)
  235.      (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
  236.           (let ((n (vector-length x)))
  237.                (let loop ((i 0))
  238.                     (if (= i n)
  239.                          #t
  240.                          (and (equal? (vector-ref x i) (vector-ref y i))
  241.                               (loop (succ i))))))))
  242.  
  243. (define (list->vector x)
  244.      (apply vector x))
  245.  
  246. (define (vector-fill! v e)
  247.      (let ((n (vector-length v)))
  248.           (let loop ((i 0))
  249.                (if (= i n)
  250.                     v
  251.                     (begin (vector-set! v i e) (loop (succ i)))))))
  252.  
  253. (define (vector->list v)
  254.      (let loop ((n (pred (vector-length v))) (l '()))
  255.           (if (= n -1)
  256.                l
  257.                (loop (pred n) (cons (vector-ref v n) l)))))
  258.  
  259. ;; The following quasiquote macro is due to Eric S. Tiedemann.
  260. ;;   Copyright 1988 by Eric S. Tiedemann; all rights reserved.
  261. ;;
  262. ;; Subsequently modified to handle vectors: D. Souflis
  263.  
  264. (macro
  265.  quasiquote
  266.  (lambda (l)
  267.    (define (mcons f l r)
  268.      (if (and (pair? r)
  269.               (eq? (car r) 'quote)
  270.               (eq? (car (cdr r)) (cdr f))
  271.               (pair? l)
  272.               (eq? (car l) 'quote)
  273.               (eq? (car (cdr l)) (car f)))
  274.          (if (or (procedure? f) (number? f) (string? f))
  275.                f
  276.                (list 'quote f))
  277.          (if (eqv? l vector)
  278.                (apply l (eval r))
  279.                (list 'cons l r)
  280.                )))
  281.    (define (mappend f l r)
  282.      (if (or (null? (cdr f))
  283.              (and (pair? r)
  284.                   (eq? (car r) 'quote)
  285.                   (eq? (car (cdr r)) '())))
  286.          l
  287.          (list 'append l r)))
  288.    (define (foo level form)
  289.      (cond ((not (pair? form))
  290.                (if (or (procedure? form) (number? form) (string? form))
  291.                     form
  292.                     (list 'quote form))
  293.                )
  294.            ((eq? 'quasiquote (car form))
  295.             (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
  296.            (#t (if (zero? level)
  297.                    (cond ((eq? (car form) 'unquote) (car (cdr form)))
  298.                          ((eq? (car form) 'unquote-splicing)
  299.                           (error "Unquote-splicing wasn't in a list:"
  300.                                  form))
  301.                          ((and (pair? (car form))
  302.                                (eq? (car (car form)) 'unquote-splicing))
  303.                           (mappend form (car (cdr (car form)))
  304.                                    (foo level (cdr form))))
  305.                          (#t (mcons form (foo level (car form))
  306.                                          (foo level (cdr form)))))
  307.                    (cond ((eq? (car form) 'unquote)
  308.                           (mcons form ''unquote (foo (- level 1)
  309.                                                      (cdr form))))
  310.                          ((eq? (car form) 'unquote-splicing)
  311.                           (mcons form ''unquote-splicing
  312.                                       (foo (- level 1) (cdr form))))
  313.                          (#t (mcons form (foo level (car form))
  314.                                          (foo level (cdr form)))))))))
  315.    (foo 0 (car (cdr l)))))
  316.  
  317.  
  318. ;;;;; atom? and equal? written by a.k
  319.  
  320. ;;;; atom?
  321. (define (atom? x)
  322.   (not (pair? x)))
  323.  
  324. ;;;;    equal?
  325. (define (equal? x y)
  326.      (cond
  327.           ((pair? x)
  328.                (and (pair? y)
  329.                     (equal? (car x) (car y))
  330.                     (equal? (cdr x) (cdr y))))
  331.           ((vector? x)
  332.                (and (vector? y) (vector-equal? x y)))
  333.           ((string? x)
  334.                (and (string? y) (string=? x y)))
  335.           (else (eqv? x y))))
  336.  
  337. ;;;; (do ((var init inc) ...) (endtest result ...) body ...)
  338. ;;
  339. (macro do
  340.   (lambda (do-macro)
  341.     (apply (lambda (do vars endtest . body)
  342.              (let ((do-loop (gensym)))
  343.                `(letrec ((,do-loop
  344.                            (lambda ,(map (lambda (x)
  345.                                            (if (pair? x) (car x) x))
  346.                                       `,vars)
  347.                              (if ,(car endtest)
  348.                                (begin ,@(cdr endtest))
  349.                                (begin
  350.                                  ,@body
  351.                                  (,do-loop
  352.                                    ,@(map (lambda (x)
  353.                                             (cond
  354.                                               ((not (pair? x)) x)
  355.                                               ((< (length x) 3) (car x))
  356.                                               (else (car (cdr (cdr x))))))
  357.                                        `,vars)))))))
  358.                   (,do-loop
  359.                     ,@(map (lambda (x)
  360.                              (if (and (pair? x) (cdr x))
  361.                                (car (cdr x))
  362.                                '()))
  363.                         `,vars)))))
  364.       do-macro)))
  365.  
  366. ;;;; generic-member
  367. (define (generic-member cmp obj lst)
  368.   (cond
  369.     ((null? lst) #f)
  370.     ((cmp obj (car lst)) lst)
  371.     (else (generic-member cmp obj (cdr lst)))))
  372.  
  373. (define (memq obj lst)
  374.      (generic-member eq? obj lst))
  375. (define (memv obj lst)
  376.      (generic-member eqv? obj lst))
  377. (define (member obj lst)
  378.      (generic-member equal? obj lst))
  379.  
  380. ;;;; generic-assoc
  381. (define (generic-assoc cmp obj alst)
  382.      (cond
  383.           ((null? alst) #f)
  384.           ((cmp obj (caar alst)) (car alst))
  385.           (else (generic-assoc cmp obj (cdr alst)))))
  386.  
  387. (define (assq obj alst)
  388.      (generic-assoc eq? obj alst))
  389. (define (assv obj alst)
  390.      (generic-assoc eqv? obj alst))
  391. (define (assoc obj alst)
  392.      (generic-assoc equal? obj alst))
  393.  
  394. (define (acons x y z) (cons (cons x y) z))
  395.  
  396. ;;;; Utility to ease macro creation
  397. (define (macro-expand form)
  398.      ((eval (get-closure-code (eval (car form)))) form))
  399.  
  400. ;;;; Handy for imperative programs
  401. ;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
  402. (macro (define-with-return form)
  403.      `(define ,(cadr form)
  404.           (call/cc (lambda (return) ,@(cddr form)))))
  405.  
  406. ;;;; Simple exception handling
  407. ;
  408. ;    Exceptions are caught as follows:
  409. ;
  410. ;         (catch (do-something to-recover and-return meaningful-value)
  411. ;              (if-something goes-wrong)
  412. ;              (with-these calls))
  413. ;
  414. ;    "Catch" establishes a scope spanning multiple call-frames
  415. ;    until another "catch" is encountered.
  416. ;
  417. ;    Exceptions are thrown with:
  418. ;
  419. ;         (throw "message")
  420. ;
  421. ;    If used outside a (catch ...), reverts to (error "message)
  422.  
  423. (define *handlers* (list))
  424.  
  425. (define (push-handler proc)
  426.      (set! *handlers* (cons proc *handlers*)))
  427.  
  428. (define (pop-handler)
  429.      (let ((h (car *handlers*)))
  430.           (set! *handlers* (cdr *handlers*))
  431.           h))
  432.  
  433. (define (more-handlers?)
  434.      (pair? *handlers*))
  435.  
  436. (define (throw . x)
  437.      (if (more-handlers?)
  438.           (apply (pop-handler))
  439.           (apply error x)))
  440.  
  441. (macro (catch form)
  442.      (let ((label (gensym)))
  443.           `(call/cc (lambda (exit)
  444.                (push-handler (lambda () (exit ,(cadr form))))
  445.                (let ((,label (begin ,@(cddr form))))
  446.                     (pop-handler)
  447.                     ,label)))))
  448.  
  449. (define *error-hook* throw)
  450.  
  451.  
  452. ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
  453.  
  454. (macro (make-environment form)
  455.      `(apply (lambda ()
  456.                ,@(cdr form)
  457.                (current-environment))))
  458.  
  459. (define-macro (eval-polymorphic x . envl)
  460.   (display envl)
  461.   (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
  462.          (xval (eval x env)))
  463.     (if (closure? xval)
  464.     (make-closure (get-closure-code xval) env)
  465.     xval)))
  466.  
  467. ; Redefine this if you install another package infrastructure
  468. ; Also redefine 'package'
  469. (define *colon-hook* eval)
  470.  
  471. ;;;;; I/O
  472.  
  473. (define (input-output-port? p)
  474.      (and (input-port? p) (output-port? p)))
  475.  
  476. (define (close-port p)
  477.      (cond
  478.           ((input-output-port? p) (close-input-port (close-output-port p)))
  479.           ((input-port? p) (close-input-port p))
  480.           ((output-port? p) (close-output-port p))
  481.           (else (throw "Not a port" p))))
  482.  
  483. (define (call-with-input-file s p)
  484.      (let ((inport (open-input-file s)))
  485.           (if (eq? inport #f)
  486.                #f
  487.                (let ((res (p inport)))
  488.                     (close-input-port inport)
  489.                     res))))
  490.  
  491. (define (call-with-output-file s p)
  492.      (let ((outport (open-output-file s)))
  493.           (if (eq? outport #f)
  494.                #f
  495.                (let ((res (p outport)))
  496.                     (close-output-port outport)
  497.                     res))))
  498.  
  499. (define (with-input-from-file s p)
  500.      (let ((inport (open-input-file s)))
  501.           (if (eq? inport #f)
  502.                #f
  503.                (let ((prev-inport (current-input-port)))
  504.                     (set-input-port inport)
  505.                     (let ((res (p)))
  506.                          (close-input-port inport)
  507.                          (set-input-port prev-inport)
  508.                          res)))))
  509.  
  510. (define (with-output-to-file s p)
  511.      (let ((outport (open-output-file s)))
  512.           (if (eq? outport #f)
  513.                #f
  514.                (let ((prev-outport (current-output-port)))
  515.                     (set-output-port outport)
  516.                     (let ((res (p)))
  517.                          (close-output-port outport)
  518.                          (set-output-port prev-outport)
  519.                          res)))))
  520.  
  521. (define (with-input-output-from-to-files si so p)
  522.      (let ((inport (open-input-file si))
  523.            (outport (open-input-file so)))
  524.           (if (not (and inport outport))
  525.                (begin
  526.                     (close-input-port inport)
  527.                     (close-output-port outport)
  528.                     #f)
  529.                (let ((prev-inport (current-input-port))
  530.                      (prev-outport (current-output-port)))
  531.                     (set-input-port inport)
  532.                     (set-output-port outport)
  533.                     (let ((res (p)))
  534.                          (close-input-port inport)
  535.                          (close-output-port outport)
  536.                          (set-input-port prev-inport)
  537.                          (set-output-port prev-outport)
  538.                          res)))))
  539.  
  540. ; Random number generator (maximum cycle)
  541. (define *seed* 1)
  542. (define (random-next)
  543.      (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
  544.           (set! *seed*
  545.                (-   (* a (- *seed*
  546.                          (* (quotient *seed* q) q)))
  547.                     (* (quotient *seed* q) r)))
  548.           (if (< *seed* 0) (set! *seed* (+ *seed* m)))
  549.           *seed*))
  550. ;; SRFI-0
  551. ;; COND-EXPAND
  552. ;; Implemented as a macro
  553. (define *features* '(srfi-0))
  554.  
  555. (define-macro (cond-expand . cond-action-list)
  556.   (cond-expand-runtime cond-action-list))
  557.  
  558. (define (cond-expand-runtime cond-action-list)
  559.   (if (null? cond-action-list)
  560.       #t
  561.       (if (cond-eval (caar cond-action-list))
  562.           `(begin ,@(cdar cond-action-list))
  563.           (cond-expand-runtime (cdr cond-action-list)))))
  564.  
  565. (define (cond-eval-and cond-list)
  566.   (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
  567.  
  568. (define (cond-eval-or cond-list)
  569.   (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
  570.  
  571. (define (cond-eval condition)
  572.   (cond ((symbol? condition)
  573.      (if (member condition *features*) #t #f))
  574.     ((eq? condition #t) #t)
  575.     ((eq? condition #f) #f)
  576.     (else (case (car condition)
  577.         ((and) (cond-eval-and (cdr condition)))
  578.         ((or) (cond-eval-or (cdr condition)))
  579.         ((not) (if (not (null? (cddr condition)))
  580.                (error "cond-expand : 'not' takes 1 argument")
  581.                (not (cond-eval (cadr condition)))))
  582.         (else (error "cond-expand : unknown operator" (car condition)))))))
  583.  
  584. (gc-verbose #f)
  585.